Developer CD Series 1999 …ember: Reference Library/Apple Developer Reference Library (December 1999) (Disk 1).iso/pc/technical documentation/macintosh technotes and q&as/technotes/tn/tn1120.hqx/TestOpenResFile.1/TestOpenResFile.p

Text File | 1999-07-20 | 9.6 KB | 370 lines

program TestOpenResFile;

(*
    File:        TestOpenResFile.c

    Contains:    Tests the rules for the Resource Manager's open routines.

    Written by:    Quinn "The Eskimo!"

    Copyright:    © 1997 by Apple Computer, Inc., all rights reserved.

    Change History (most recent first):

    You may incorporate this sample code into your applications without
    restriction, though the sample code has been provided "AS IS" and the
    responsibility for its operation is 100% yours.  However, what you are
    not permitted to do is to redistribute the source as "DSC Sample Code"
    after having made changes. If you're going to re-distribute the source,
    we require that you make it clear in the source that the code was
    descended from Apple Sample Code, but that you've made changes.
*)

    uses
        Types,
        Files,
        LowMem,
        GestaltEqu;

    procedure Assert(mustBeTrue : Boolean);
    begin
        if not mustBeTrue then begin
            DebugStr('Assert: Assertion failed.');
        end; (* if *)
    end; (* Assert *)

    type
        OpenResFileRoutine = (
                kOpenResFile,
                kOpenRFPerm,
                kHOpenResFile,
                kFSpOpenResFile
            );

    function OpenResFileRoutineToString(routine : OpenResFileRoutine) : Str31;
    begin
        case routine of
            kOpenResFile :
                OpenResFileRoutineToString := 'kOpenResFile';
            kOpenRFPerm :
                OpenResFileRoutineToString := 'kOpenRFPerm';
            kHOpenResFile :
                OpenResFileRoutineToString := 'kHOpenResFile';
            kFSpOpenResFile :
                OpenResFileRoutineToString := 'kFSpOpenResFile';
        end; (* case *)
    end; (* OpenResFileRoutineToString *)

    function FSPermToString(perm : ByteParameter) : Str31;
    begin
        case perm of
            fsCurPerm :
                FSPermToString := 'fsCurPerm';
            fsRdPerm :
                FSPermToString := 'fsRdPerm';
            fsWrPerm :
                FSPermToString := 'fsWrPerm';
            fsRdWrPerm :
                FSPermToString := 'fsRdWrPerm';
        end; (* case *)
    end; (* FSPermToString *)

{$PUSH}
{$ALIGN MAC68K}
    type
        ResourceMapHandle = ^ResourceMapPtr;
        ResourceMapPtr = ^ResourceMap;
        ResourceMap =
            record
                junk : packed array [0..15] of Byte;
                next : ResourceMapHandle;
                fileRefNum : integer;
            end;
{$ALIGN RESET}
{$POP}
    const
        kSystemResourceFileRefNum = 2;
        kROMResourceBogusFileRefNum = 3;

    type
        DumpResourceChainStyle = (kShortDump, kLongDump);

    procedure DumpResourceChain(style : DumpResourceChainStyle);
        var
            currentMap : ResourceMapHandle;
            fcbPB : FCBPBRec;
            fileNameString : Str255;
            arrowStr : Str31;
    begin
        writeln('DumpResourceChain');
        currentMap := ResourceMapHandle(LMGetTopMapHndl);
        while currentMap <> nil do begin
            if currentMap^^.fileRefNum = CurResFile then begin
                arrowStr := '>'
            end else begin
                arrowStr := ' ';
            end; (* if *)
            write('  ', arrowStr, ' fileRefNum = ', currentMap^^.fileRefNum:6);
            fcbPB.ioNamePtr := @fileNameString;
            fcbPB.ioVRefNum := 0;
            fcbPB.ioRefNum := currentMap^^.fileRefNum;
            fcbPB.ioFCBIndx := 0;
            if PBGetFCBInfoSync(@fcbPB) = noErr then begin
                if btst(fcbPB.ioFCBFlags, 8) then begin
                    write(' R/W');
                end else begin
                    write(' R-O');
                end; (* if *)
                writeln('  ', fileNameString);
            end else if currentMap^^.fileRefNum = kROMResourceBogusFileRefNum then begin
                writeln(' xxx  ROM Resources');
            end else begin
                writeln;
            end; (* if *)

            if (style = kShortDump) and (currentMap^^.fileRefNum = kSystemResourceFileRefNum) then begin
                leave;
            end; (* if *)

            currentMap := currentMap^^.next;
        end; (* while *)
        writeln;
    end; (* DumpResourceChain *)

    var
        gApplicationResFile : integer;

    procedure CloseExtraResourceFiles;
        var
            done : Boolean;
            currentMap : ResourceMapHandle;
    begin
        writeln('CloseExtraResourceFiles');
        repeat
            currentMap := ResourceMapHandle(LMGetTopMapHndl);
            Assert(currentMap <> nil);
            done := (currentMap^^.fileRefNum = gApplicationResFile);
            if not done then begin
                writeln('  Closing ', currentMap^^.fileRefNum);
                CloseResFile(currentMap^^.fileRefNum);
            end; (* if *)
        until done;
        writeln;
    end; (* DumpResourceChain *)

    function MyOpenResFile(routine : OpenResFileRoutine; perm : ByteParameter; name : Str63;
                                var resourceRefNum : integer) : OSStatus;
        var
            err : OSStatus;
            tmpFSS : FSSpec;
            junk : OSErr;
    begin
        writeln('  Opening ', name);
        case routine of
            kOpenResFile :
                begin
                    Assert(perm = fsCurPerm);
                    resourceRefNum := OpenResFile(name);
                    err := ResError;
                end;
            kOpenRFPerm :
                begin
                    resourceRefNum := OpenRFPerm(name, 0, perm);
                    err := ResError;
                end;
            kHOpenResFile :
                begin
                    resourceRefNum := HOpenResFile(0, 0, name, perm);
                    err := ResError;
                end;
            kFSpOpenResFile :
                begin
                    junk := FSMakeFSSpec(0, 0, name, tmpFSS);
                    resourceRefNum := FSpOpenResFile(tmpFSS, perm);
                    err := ResError;
                end;
        end; (* case *)
        writeln('  err = ', err:1, ' resourceRefNum = ', resourceRefNum:1);
        MyOpenResFile := err;
    end; (* MyOpenResFile *)

    procedure TestOpenResFileSingleProcess(routine : OpenResFileRoutine; perm1, perm2 : ByteParameter);
        var
            err : OSStatus;
            resourceRefNum : integer;
    begin
        writeln('TestOpenResFileSingleProcess ', OpenResFileRoutineToString(routine), ' ', FSPermToString(perm1), ' ', FSPermToString(perm2));

        err := MyOpenResFile(routine, perm1, 'File A', resourceRefNum);

        if err = noErr then begin
            err := MyOpenResFile(kHOpenResFile, fsRdPerm, 'File B', resourceRefNum);
        end; (* if *)

        if err = noErr then begin
            err := MyOpenResFile(routine, perm2, 'File A', resourceRefNum);
            DumpResourceChain(kShortDump);
        end; (* if *)

        CloseExtraResourceFiles;

        if err = noErr then begin
            writeln('  Success!');
        end else begin
            writeln('  Failed with error ', err:1, '!');
        end; (* if *)
        writeln;
        writeln;
    end; (* TestOpenResFileSingleProcess *)

    procedure SingleProcessTest;
        var
            routine : OpenResFileRoutine;
            perm1 : integer;
            perm2 : integer;
    begin
        writeln('Single Process Test');
        writeln('-------------------');
        writeln;
        for routine := kOpenResFile to kFSpOpenResFile do begin
            for perm1 := fsCurPerm to fsRdWrPerm do begin
                for perm2 := fsCurPerm to fsRdWrPerm do begin
                    if (routine = kOpenResFile) and ((perm1 <> fsCurPerm) or (perm2 <> fsCurPerm)) then begin
                        (* test skipped *)
                    end else begin
                        TestOpenResFileSingleProcess(routine, perm1, perm2);
                    end; (* if *)
                end; (* for *)
            end; (* for *)
        end; (* for *)
    end; (* SingleProcessTest *)

    procedure PassiveDoubleProcessTest;
        var
            err : OSStatus;
            resourceRefNum : integer;
    begin
        writeln('Passive Double Process Test');
        writeln('---------------------------');
        writeln;
        err := MyOpenResFile(kFSpOpenResFile, fsCurPerm, 'File A', resourceRefNum);
        if err = noErr then begin
            err := MyOpenResFile(kFSpOpenResFile, fsRdPerm, 'File B', resourceRefNum);
        end; (* if *)
        if err = noErr then begin
            err := MyOpenResFile(kFSpOpenResFile, fsWrPerm, 'File C', resourceRefNum);
        end; (* if *)
        if err = noErr then begin
            err := MyOpenResFile(kFSpOpenResFile, fsRdWrPerm, 'File D', resourceRefNum);
        end; (* if *)
        DumpResourceChain(kShortDump);

        if err = noErr then begin
            writeln('Files are opened.');
            writeln('Hit return to continue.');
            readln;
        end; (* if *)

        CloseExtraResourceFiles;

        if err = noErr then begin
            writeln('  Success!');
        end else begin
            writeln('  Failed with error ', err:1, '!');
        end; (* if *)
        writeln;
        writeln;
    end; (* PassiveDoubleProcessTest *)

    procedure TestOpenResFileDoubleProcess(routine : OpenResFileRoutine; perm1, perm2 : ByteParameter);
        var
            err : OSStatus;
            resourceRefNum : integer;
            fileName : Str63;
    begin
        writeln('TestOpenResFileDoubleProcess ', OpenResFileRoutineToString(routine), ' ', FSPermToString(perm1), ' ', FSPermToString(perm2));

        fileName := concat('File ', chr( ord('A') + ord(perm1) ) );

        err := MyOpenResFile(routine, perm2, fileName, resourceRefNum);

        DumpResourceChain(kShortDump);

        CloseExtraResourceFiles;

        if err = noErr then begin
            writeln('  Success!');
        end else begin
            writeln('  Failed with error ', err:1, '!');
        end; (* if *)
        writeln;
        writeln;
    end; (* TestOpenResFileDoubleProcess *)

    procedure ActiveDoubleProcessTest;
        var
            routine : OpenResFileRoutine;
            perm1 : integer;
            perm2 : integer;
    begin
        writeln('Active Double Process Test');
        writeln('--------------------------');
        writeln;

        for routine := kOpenResFile to kFSpOpenResFile do begin
            for perm1 := fsCurPerm to fsRdWrPerm do begin
                for perm2 := fsCurPerm to fsRdWrPerm do begin
                    if (routine = kOpenResFile) and ((perm1 <> fsCurPerm) or (perm2 <> fsCurPerm)) then begin
                        (* test skipped *)
                    end else begin
                        TestOpenResFileDoubleProcess(routine, perm1, perm2);
                    end; (* if *)
                end; (* for *)
            end; (* for *)
        end; (* for *)

    end; (* ActiveDoubleProcessTest *)

    var
        testChar : char;
        sysv : SInt32;
        mach : SInt32;
begin
    writeln('TestOpenResFile');
    if Gestalt(gestaltSystemVersion, sysv) <> noErr then begin
        sysv := 0;
    end; (* if *)
    if Gestalt(gestaltMachineType, mach) <> noErr then begin
        mach := 0;
    end; (* if *)
    writeln('  System Version = ', Ptr(sysv):1);
    writeln('  Machine ID     = ', Ptr(mach):1);
    writeln;

    gApplicationResFile := CurResFile;

    writeln('a) Single process test');
    writeln('b) Passive double process test');
    writeln('c) Active double process test');
    writeln;
    writeln('Enter the letter of the test you would like to run:');

    readln(testChar);

    writeln;
    writeln;

    case testChar of
        'a' :
            SingleProcessTest;
        'b' :
            PassiveDoubleProcessTest;
        'c' :
            ActiveDoubleProcessTest;
        otherwise
            writeln('“', testChar, '” is not a valid test.');
    end; (* case *)

    writeln('Done.  Press command-Q to Quit.');
end. (* QStandardP68K *)